Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/msflex2a/grid.frm

Visual Basic Form | 1999-09-24 | 15.2 KB | 476 lines

VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form BackGrnd
   AutoRedraw      =   -1  'True
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Test Grid"
   ClientHeight    =   3360
   ClientLeft      =   45
   ClientTop       =   360
   ClientWidth     =   4695
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   Moveable        =   0   'False
   ScaleHeight     =   3360
   ScaleWidth      =   4695
   StartUpPosition =   2  'CenterScreen
   Begin VB.CheckBox AutoReturn
      Caption         =   "Auto Return to Col. 1"
      Height          =   255
      Left            =   2640
      TabIndex        =   4
      TabStop         =   0   'False
      Top             =   120
      Width           =   1815
   End
   Begin VB.CommandButton Stop
      Caption         =   "STOP"
      Height          =   375
      Left            =   1920
      TabIndex        =   2
      Top             =   2880
      Width           =   975
   End
   Begin VB.TextBox T1
      Appearance      =   0  'Flat
      BackColor       =   &H00C0FFFF&
      BorderStyle     =   0  'None
      Height          =   285
      Left            =   2160
      MaxLength       =   20
      TabIndex        =   1
      Top             =   1200
      Visible         =   0   'False
      Width           =   975
   End
   Begin MSFlexGridLib.MSFlexGrid FG1
      Height          =   2415
      Left            =   240
      TabIndex        =   0
      Top             =   360
      Width           =   4215
      _ExtentX        =   7435
      _ExtentY        =   4260
      _Version        =   393216
      Rows            =   30
      Cols            =   10
      AllowBigSelection=   0   'False
      ScrollTrack     =   -1  'True
      FillStyle       =   1
   End
   Begin VB.Label CellIndicator
      Appearance      =   0  'Flat
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   1  'Fixed Single
      ForeColor       =   &H80000008&
      Height          =   255
      Left            =   240
      TabIndex        =   3
      Top             =   120
      UseMnemonic     =   0   'False
      Width           =   105
   End
   Begin VB.Menu MnuFGridRows
      Caption         =   "Row Popup"
      Visible         =   0   'False
      Begin VB.Menu MnuFGridAddRow
         Caption         =   "Add a Row"
      End
      Begin VB.Menu MnuFGridInsRow
         Caption         =   "Insert a Row"
      End
      Begin VB.Menu MnuFGridDelRow
         Caption         =   "Delete a Row"
      End
      Begin VB.Menu MnuFGridExtrRow
         Caption         =   "Extract a Row"
      End
   End
   Begin VB.Menu MnuFGridCols
      Caption         =   "Col Popup"
      Visible         =   0   'False
      Begin VB.Menu MnuFGridAddCol
         Caption         =   "Add a Col"
      End
      Begin VB.Menu MnuFGridInsCol
         Caption         =   "Insert a Col"
      End
      Begin VB.Menu MnuFGridDelCol
         Caption         =   "Delete a Col"
      End
      Begin VB.Menu MnuFGridExtrCol
         Caption         =   "Extract a Col"
      End
   End
Attribute VB_Name = "BackGrnd"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'MSFlexgrid Edit : 9-12-99
'this is an effective and completely natural looking way
'to edit data in the MSFlexgrid object. I've chosen to keep
'all columns the same width that is why I've used .TextMatrix
'in Form_Load() below rather than .Format$.
'If you don't care that numbers and chars wind up aligned
'differently in the columns then remove .ColAlignment(-1)=1
'in the Form_Load() sub.
'Move the cell around with the cursor keys or click with
'the mouse on the destination cell.
'Starting to type will replace the current value in that cell.
'If you wish to edit the existing text in a cell then press F2.
'You can enter a cell, drag the mouse and then start typing and
'VOILA you fill in all the hi-lited cells. The same thing can
'be achieved by pressing the SHIFT & CURSOR keys. (This is also
'an effective way of erasing a whole block of data.)
'<ENTER> key advances to the next cell.
'If you can improve the code...COOL, let me know.
'9-13-99
'Went through the code and eliminated some dead code from
'previous versions as well as some typos.
'Navigtion keys are the usual <Home>, <End>, <Pg Up / Dn>
'along with their Ctrl alternates
'9-14-99
'added a Cell indicator - may come in handy in BIG Grids
'Also added a choice button to autom. return the focus
'to the first column or just go down 1 row
'similar thing can be accomplished like so:
'( in Incr_Cell() )
'   if Fg1.ColIsVisible(1) then
'       FG1.Col=1
'   end if
'9-23-99
'added In-Cell cursor control to move to adjacent cells for
'up/dn anytime, right/left when cursor pos is either right
'or leftmost, in cell, respectively. When in the last cell
'(and editing) Right cursor will advance to next row col 1.
'When in the first cell (and editing) Left cursor will jump
'to last cell one row up.
'Typing into a cell with existing data OVERWRITES unless you
'press F2, but if you forget you can now press <ESC> and
'restore the previous value (before exiting the cell).
'also added Popupmenus for Adding, Deleting, Inserting and
'Extracting either Rows or Cols.
'Just put mouse in Col 0 or Row 0 and click Right Mouse Button.
'Add - means add Row at bottom or Col at end
'Delete - means del LAST Row or LAST Col
'Insert - means INSERT a Row / Col at present cursor pos.
'Extract - means EXTRACT a Row /Col at present cursor pos.
'If you try to DELETE / EXTRACT a Row / Col that has data
'in it you will be prompted if you wish to proceed.
'The Popupmenus were created the usual way and then had their
'Titles set to : Visible = False
'9-24-99 minor fix to T1_KeyDown.... Case 27, 37-40
'otherwise it adds a char to the text in Case Else!
'Now posted as as .vbp file
'Peter Raddatz - [e-mail]
Private Sub Form_Load()
    Dim y%
    With FG1
    .ColAlignment(-1) = 1
    For y% = 1 To .Cols - 1
        .TextMatrix(0, y%) = "Col " + Str(y%)
    Next
    For y% = 1 To FG1.Rows - 1
        .TextMatrix(y%, 0) = "Row " + Str(y%)
    Next
    .Row = 1
    .Col = 1
    .CellBackColor = &HC0FFFF   'lt. yellow
    BackGrnd.CellIndicator = " " + .TextMatrix(.Row, 0) + " : " + .TextMatrix(0, .Col) + " "
    End With
End Sub
Private Sub AutoReturn_Click()
    FG1.SetFocus
End Sub
Private Sub FG1_EnterCell()
    BackGrnd.CellIndicator = " " + FG1.TextMatrix(FG1.Row, 0) + " : " + FG1.TextMatrix(0, FG1.Col) + " "
    T1.Visible = False
    FG1.Tag = FG1
    FG1.CellBackColor = &HC0FFFF    'lt. yellow
    FG1.SetFocus
End Sub
Private Sub FG1_LeaveCell()
    FG1.CellBackColor = &H80000005  'white
End Sub
Private Sub FG1_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case 113        'F2
            Set_TextBox
    End Select
End Sub
Private Sub FG1_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case 13         'ENTER key
            KeyCode = 0
            INCR_CELL
        Case 8      'BkSpc
            FG1 = Left$(FG1, Len(FG1) - 1)
            Set_TextBox
        Case 27     'Esc - ignore
        Case Else
            FG1 = Chr$(KeyAscii)
            T1 = Chr$(KeyAscii)
            Set_TextBox
    End Select
End Sub
Private Sub T1_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
    Case 27     'ESC - OOPS, restore old text
        T1 = FG1.Tag
        T1.SelStart = Len(T1)
    Case 37     'Left Arrow
        If T1.SelStart = 0 And FG1.Col > 1 Then
            FG1.Col = FG1.Col - 1
        Else
            If T1.SelStart = 0 And FG1.Row > 1 Then
                FG1.Row = FG1.Row - 1
                FG1.Col = FG1.Cols - 1
            End If
        End If
    Case 38     'Up Arrow
        If FG1.Row > 1 Then
            FG1.Row = FG1.Row - 1
        End If
    Case 39     'Rt Arrow
        If T1.SelStart = Len(T1) And FG1.Col < FG1.Cols - 1 Then
            FG1.Col = FG1.Col + 1
        Else
            If T1.SelStart = Len(T1) And FG1.Row < FG1.Rows - 1 Then
                FG1.Row = FG1.Row + 1
                FG1.Col = 1
            End If
        End If
    Case 40     'Dn Arrow
        If FG1.Row < FG1.Rows - 1 Then
            FG1.Row = FG1.Row + 1
        End If
End Select
    IsCellVisible
End Sub
Private Sub T1_KeyPress(KeyAscii As Integer)
    Dim pos%, l$, R$
    Select Case KeyAscii
        Case 13
            KeyAscii = 0
            FG1 = T1
            T1.Visible = False
            INCR_CELL
            FG1.SetFocus
        Case 8                      'BkSpc - split string @ cursor
            pos% = T1.SelStart - 1 'where is the cursor?
            If pos% >= 0 Then
                l$ = Left$(FG1, pos%)       'left of cursor
                R$ = Right$(FG1, Len(FG1) - pos% - 1) 'right of cursor
                FG1.Text = l$ + R$          'depleted string into fg1
            End If
        Case 27, 37 To 40
            FG1 = T1        'or it's going to look funny
        Case Else
            FG1 = T1 + Chr(KeyAscii)
    End Select
End Sub
Private Sub FG1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim Row%, Col%
T1.Visible = False
Row% = FG1.MouseRow
Col% = FG1.MouseCol
If Button = 2 And (Col% = 0 Or Row% = 0) Then
    FG1.Col = IIf(Col% = 0, 1, Col%)    'rows?
    FG1.Row = IIf(Row% = 0, 1, Row%)    'or cols?
    If Col% Then
        PopupMenu MnuFGridCols
    Else
        PopupMenu MnuFGridRows
    End If
End If
End Sub
Private Sub MnuFGridAddCol_Click()
With FG1
    .Cols = .Cols + 1
    .Col = .Cols - 1
    .TextMatrix(0, .Col) = "Col " + Str(.Col)
End With
IsCellVisible
End Sub
Private Sub MnuFGridAddRow_Click()
With FG1
    .Rows = .Rows + 1
    .Row = .Rows - 1
    .TextMatrix(.Row, 0) = "Row " + Str(.Row)
End With
IsCellVisible
End Sub
Private Sub MnuFGridDelCol_Click()
Dim R%, C%, Col%
If FG1.Cols > 2 Then        'make sure we don't del col 1
    Col% = FG1.Cols - 1
    For R% = 1 To FG1.Rows - 1
        If FG1.TextMatrix(R%, Col%) > "" Then   'data?
            C% = 1
            Exit For
        End If
    Next R%
    If C% Then
        R% = MsgBox("There is data in Col" + Str$(Col%) + " ! Delete anyway?", vbYesNo, "Delete Column!")
    End If
    If C% = 0 Or R% = 6 Then    'no exist data or YES
        If FG1.Col = FG1.Cols - 1 Then  'last col?
            FG1.Col = FG1.Col - 1       'move active cell
        End If
        FG1.Cols = FG1.Cols - 1         'del lat col
    End If
End If
End Sub
Private Sub MnuFGridDelRow_Click()
Dim R%, C%, Row%
If FG1.Rows > 2 Then        'make sure we don't del row 1
    Row% = FG1.Rows - 1
    For R% = 1 To FG1.Cols - 1
        If FG1.TextMatrix(Row%, R%) > "" Then   'data?
            C% = 1
            Exit For
        End If
    Next R%
    If C% Then
        R% = MsgBox("There is data in Row" + Str$(Row%) + " ! Delete anyway?", vbYesNo, "Delete Row!")
    End If
    If C% = 0 Or R% = 6 Then        'no exist. data or YES
        If FG1.Row = FG1.Rows - 1 Then  'last row?
            FG1.Row = FG1.Row - 1       'move active cell
        End If
        FG1.Rows = FG1.Rows - 1     'del last row
    End If
End If
End Sub
Private Sub MnuFGridInsRow_Click()
Dim R%, Row%, Col%
With FG1
R% = .Row
.Rows = .Rows + 1               'add a row
.TextMatrix(.Rows - 1, 0) = "Row " + Str$(.Rows - 1)    'new row title
For Row% = .Rows - 1 To R% + 1 Step -1 'move data dn 1 row
    For Col% = 1 To .Cols - 1
        .TextMatrix(Row%, Col%) = .TextMatrix(Row% - 1, Col%)
    Next Col%
Next Row%
For Col% = 1 To .Cols - 1       ' clear all cells in this row
    .TextMatrix(R%, Col%) = ""
Next Col%
End With
T1.Visible = False
End Sub
Private Sub MnuFGridInsCol_Click()
Dim C%, Row%, Col%
With FG1
C% = .Col
.Cols = .Cols + 1               'add a col
.ColAlignment(-1) = 1           'set col alignment
.TextMatrix(0, .Cols - 1) = "Col " + Str(.Cols - 1) 'new col title
For Row% = 1 To .Rows - 1       'move exist. data over
    For Col% = .Cols - 1 To C% + 1 Step -1
        .TextMatrix(Row%, Col%) = .TextMatrix(Row%, Col% - 1)
    Next Col%
Next Row%
For Row% = 1 To .Rows - 1       'clear all cells in this col
    .TextMatrix(Row%, C%) = ""
Next Row%
End With
T1.Visible = False
End Sub
Private Sub MnuFGridExtrRow_Click()
Dim Row%, R%, C%
With FG1
If .Rows > 2 Then        'make sure we don't del row 1
    Row% = .Row
    For R% = 1 To .Cols - 1
        If .TextMatrix(Row%, R%) > "" Then   'data?
            C% = 1
            Exit For
        End If
    Next R%
    If C% Then
        R% = MsgBox("There is data in Row" + Str$(Row%) + " ! Delete anyway?", vbYesNo, "Delete Row!")
    End If
    If C% = 0 Or R% = 6 Then        'no exist. data or YES
        For R% = .Row To .Rows - 2      'move exist data up 1 row
            For C% = 1 To FG1.Cols - 1
                .TextMatrix(R%, C%) = .TextMatrix(R% + 1, C%)
            Next C%
        Next R%
        If Row% = .Rows - 1 Then    'set new cursor row
            .Row = .Rows - 2
        End If
        .Rows = .Rows - 1           'delete last row
    End If
End If
End With
End Sub
Private Sub MnuFGridExtrCol_Click()
Dim Col%, R%, C%
With FG1
If .Cols > 2 Then        'make sure we don't del col 1
    Col% = .Col
    For R% = 1 To FG1.Rows - 1
        If .TextMatrix(R%, Col%) > "" Then   'data?
            C% = 1
            Exit For
        End If
    Next R%
    If C% Then
        R% = MsgBox("There is data in Col" + Str$(Col%) + " ! Delete anyway?", vbYesNo, "Delete Column!")
    End If
    If C% = 0 Or R% = 6 Then    'no exist data or YES
        For R% = 1 To .Rows - 1     'move exist. data left 1 col
            For C% = Col% To .Cols - 2
                .TextMatrix(R%, C%) = .TextMatrix(R%, C% + 1)
            Next C%
        Next R%
        If Col% = .Cols - 1 Then
            .Col = .Cols - 2
        End If
    .Cols = .Cols - 1           'delete last col
    End If
End If
End With
End Sub
Private Sub Stop_Click()
    End
End Sub
Private Sub INCR_CELL()     'advance to next cell
    With FG1
    .HighLight = flexHighlightNever
    If .Col < .Cols - 1 Then
        .Col = .Col + 1
    Else
        If .Row < .Rows - 1 Then
            .Row = .Row + 1                 'down 1 row
            If AutoReturn.Value Then        'auto return?
                .Col = 1                    'first column
            End If
        End If
    End If
    IsCellVisible
    .HighLight = flexHighlightAlways
    End With
End Sub
Private Sub Set_TextBox()   'put textbox over cell
    With T1
    .Top = FG1.Top + FG1.CellTop
    .Left = FG1.Left + FG1.CellLeft
    .Width = FG1.CellWidth
    .Height = FG1.CellHeight
    .Text = FG1
    .Visible = True
    .SelStart = Len(.Text)
    .SetFocus
    End With
End Sub
'this sub scrolls the cols / rows if they're not visible! (? why)
Private Sub IsCellVisible()
    Dim a As Boolean
    a = FG1.CellTop
End Sub